migrationanalysis/src/wizard/Get Directory Dialog.bas

   1 Attribute VB_Name = "BrowseDirectorysOnly"
   2 '/*************************************************************************
   3 ' *
   4 ' * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
   5 ' *
   6 ' * Copyright 2008 by Sun Microsystems, Inc.
   7 ' *
   8 ' * OpenOffice.org - a multi-platform office productivity suite
   9 ' *
  10 ' * $RCSfile: Get\040Directory\040Dialog.bas,v $
  11 ' * $Revision: 1.5.148.1 $
  12 ' *
  13 ' * This file is part of OpenOffice.org.
  14 ' *
  15 ' * OpenOffice.org is free software: you can redistribute it and/or modify
  16 ' * it under the terms of the GNU Lesser General Public License version 3
  17 ' * only, as published by the Free Software Foundation.
  18 ' *
  19 ' * OpenOffice.org is distributed in the hope that it will be useful,
  20 ' * but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ' * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ' * GNU Lesser General Public License version 3 for more details
  23 ' * (a copy is included in the LICENSE file that accompanied this code).
  24 ' *
  25 ' * You should have received a copy of the GNU Lesser General Public License
  26 ' * version 3 along with OpenOffice.org.  If not, see
  27 ' * <http://www.openoffice.org/license.html>
  28 ' * for a copy of the LGPLv3 License.
  29 ' *
  30 ' ************************************************************************/
  31
  32 ' Modified as BIF_STATUSTEXT overflows for nested folders so is no longer
  33 ' shown.
  34
  35 '=====================================================================================
  36 ' Browse for a Folder using SHBrowseForFolder API function with a callback
  37 ' function BrowseCallbackProc.
  38 '
  39 ' This Extends the functionality that was given in the
  40 ' MSDN Knowledge Base article Q179497 "HOWTO: Select a Directory
  41 ' Without the Common Dialog Control".
  42 '
  43 ' After reading the MSDN knowledge base article Q179378 "HOWTO: Browse for
  44 ' Folders from the Current Directory", I was able to figure out how to add
  45 ' a callback function that sets the starting directory and displays the
  46 ' currently selected path in the "Browse For Folder" dialog.
  47 '
  48 '
  49 ' Stephen Fonnesbeck
  50 ' steev@xmission.com
  51 ' http://www.xmission.com/~steev
  52 ' Feb 20, 2000
  53 '
  54 '=====================================================================================
  55 ' Usage:
  56 '
  57 '    Dim folder As String
  58 '    folder = BrowseForFolder(Me, "Select A Directory", "C:\startdir\anywhere")
  59 '    If Len(folder) = 0 Then Exit Sub  'User Selected Cancel
  60 '
  61 '=====================================================================================
  62
  63 Option Explicit
  64
  65 Private Const BIF_STATUSTEXT = &H4&
  66 Private Const BIF_RETURNONLYFSDIRS = 1
  67 Private Const BIF_DONTGOBELOWDOMAIN = 2
  68 Private Const MAX_PATH = 260
  69
  70 Private Const WM_USER = &H400
  71 Private Const BFFM_INITIALIZED = 1
  72 Private Const BFFM_SELCHANGED = 2
  73 Private Const BFFM_SETSELECTION = (WM_USER + 102)
  74
  75 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
  76 Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
  77 Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  78 Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  79
  80 Private Type BrowseInfo
  81   hWndOwner      As Long
  82   pIDLRoot       As Long
  83   pszDisplayName As Long
  84   lpszTitle      As Long
  85   ulFlags        As Long
  86   lpfnCallback   As Long
  87   lParam         As Long
  88   iImage         As Long
  89 End Type
  90
  91 Private m_CurrentDirectory As String   'The current directory
  92 '
  93
  94 Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String
  95   'Opens a Treeview control that displays the directories in a computer
  96
  97   Dim lpIDList As Long
  98   Dim szTitle As String
  99   Dim sBuffer As String
 100   Dim tBrowseInfo As BrowseInfo
 101   m_CurrentDirectory = StartDir & vbNullChar
 102
 103   szTitle = Title
 104   With tBrowseInfo
 105     .hWndOwner = owner.hWnd
 106     .lpszTitle = lstrcat(szTitle, "")
 107     .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN '+ BIF_STATUSTEXT
 108     .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
 109   End With
 110
 111   lpIDList = SHBrowseForFolder(tBrowseInfo)
 112   If (lpIDList) Then
 113     sBuffer = Space(MAX_PATH)
 114     SHGetPathFromIDList lpIDList, sBuffer
 115     sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
 116     BrowseForFolder = sBuffer
 117   Else
 118     BrowseForFolder = ""
 119   End If
 120
 121 End Function
 122
 123 Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
 124
 125   Dim lpIDList As Long
 126   Dim ret As Long
 127   Dim sBuffer As String
 128
 129   On Error Resume Next  'Sugested by MS to prevent an error from
 130                         'propagating back into the calling process.
 131
 132   Select Case uMsg
 133
 134     Case BFFM_INITIALIZED
 135       Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
 136
 137   End Select
 138
 139   BrowseCallbackProc = 0
 140
 141 End Function
 142
 143 ' This function allows you to assign a function pointer to a vaiable.
 144 Private Function GetAddressofFunction(add As Long) As Long
 145   GetAddressofFunction = add
 146 End Function